Games of Daze/Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso/x2ftp/msdos/source/demostu2/texture2.pas

Pascal/Delphi Source File | 1994-12-15 | 10.7 KB | 619 lines

PROGRAM Texture2;
{
  Flat Shaded Texture Mapping
  - by Bjarke Viksφe
  aug 1994

  Works the same way as "texture1.pas".
  Texture is only in 16 colours.
  So palette is set up to make it easy to fade from one shade to another.
  No real-time colour map translations - though it could have been a
  nice feature.
  And the light is still a fake. It depends on the polygons surface area!
  (hey, it's still going 70 fps on my 40Mhz '486. Really cool, hehe)

  Picture is an 320x200x256 ILBM/IFF pix called 'marbl16.lbm'.
}

{$A+,B-,G+,E+,I+,N-,X+}
{$C FIXED PRELOAD PERMANENT}

{{$DEFINE DEBUG}


USES
    DEMOINIT,ILBM256,PICTURE;

CONST
    NUMBER_FACES = 6;
    NUMBER_COORDS = 8;
    BOX = 110; {size of box}

TYPE
    SlopeType = array[0..319*2] of integer;

    FaceType = RECORD
        l1,l2,l3,l4 : byte;
    end;


VAR
    slope,textureslope : SlopeType;
    face : array[1..NUMBER_FACES] of FaceType;
    light : array[1..NUMBER_FACES] of byte;
    cbuffer : array[0..NUMBER_COORDS*2-1] of integer;

    minx,maxx : integer;

    sinustabel : array[0..639] of integer;
    v1,v2,v3 : word;
    cos1,sin1,cos2,sin2,cos3,sin3 : integer;

    texture : pScreen;


CONST
    display1 : word = $0000;
    display2 : word = $4000;
    {setup coords for a box}
    coords : array[0..NUMBER_COORDS*3-1] of integer =
        (box,box,-box, -box,box,-box, -box,-box,-box, box,-box,-box,
        box,box,box, -box,box,box, -box,-box,box, box,-box,box);


(*------------------------------------------------*)

procedure SetupSinus;
var
    i : integer;
    v, vadd : real;
begin
    v:=0.0;
    vadd:=(2.0*pi/512.0);
    for i:=0 to 639 do begin
        sinustabel[i]:=round(sin(v)*32767);
        v:=v+vadd;
    end;
end;

procedure SetupFaces;
{setup faces. Makes sure face keeps track of which coordinates it uses!}
begin
    with face[1] do begin l1:=3; l2:=2; l3:=1; l4:=0; end;
    with face[2] do begin l1:=4; l2:=5; l3:=6; l4:=7; end;
    with face[3] do begin l1:=0; l2:=1; l3:=5; l4:=4; end;
    with face[4] do begin l1:=1; l2:=2; l3:=6; l4:=5; end;
    with face[5] do begin l1:=2; l2:=3; l3:=7; l4:=6; end;
    with face[6] do begin l1:=3; l2:=0; l3:=4; l4:=7; end;
end;

procedure InitDemo;
var
    i,j,k : word;
    factor : word;
begin
    Screen_Off;
    ClearWholeScreen;
    SetupSinus;
    SetupFaces;

    New(texture);
    LoadPix(texture,'marbl16.lbm');
    {picture is 320x200. Need to convert it to 256x128}
    j:=0; k:=0;
    for i:=1 to 128 do begin
        Move(texture^[j],texture^[k],128);
        inc(j,320);
        inc(k,256);
    end;
    {set up colour map to ease shade calculations}
    {colours are made as 16 shades of the texture's 16 colours}
    k:=1;
    factor:=16;
    for i:=1 to 16 do begin
        for j:=1 to 16*3 do begin
            CMAP[k]:=CMAP[j] * 16 DIV factor;
            inc(k);
        end;
        inc(factor,3);
    end;
    SetCMAP;

    v1:=0; v2:=0; v3:=0;

    Screen_On;
end;

procedure UninitDemo;
begin
    Dispose(texture);
end;


(*------------------------------------------------*)

procedure SwapDisplay;
var
    temp : word;
begin
    temp:=display2;
    display2:=display1;
    display1:=temp;
    SetAddress(Ptr(SEGA000,display2));
end;

procedure ClearScreen; assembler;
{Clear video memory}
asm
    mov    dx,$3C4
    mov    ax,$0F02
    out    dx,ax

    mov    es,[SEGA000]
    mov    di,[display1]
    add    di,(30*WIDTH)+16
    mov    dx,140
    xor ax,ax
    mov    bx,48/2
@loop:
    mov    cx,bx
    rep stosw
    add    di,WIDTH-48
    dec    dl
    jnz    @loop
end;


(*------------------------------------------------*)

procedure ClearSlope; assembler;
asm
    mov    ax,ds
    mov    es,ax
    lea    di,slope
    DB LONG; mov ax,$8000; DW $8000;
    cld
    mov    cx,TYPE(slopetype)/4
    rep; DB LONG; stosw
end;

procedure CalcSlope(l1,l2 : integer; tex1x,tex2x,tex1y,tex2y : word); assembler;
{Calc edge buffer for line drawing/texture mapping.
 tex1x/tex1y is texture map position (x1,y1), tex2x/tex2y is texture map position (x2,y2)}
var
    tex1xadd,tex1yadd : word;
    xlowadd,xhighadd : word;
    ysize : integer;
asm
    lea    si,cbuffer
    DB LONG; xor cx,cx
    mov    bx,l1                    {get first coords}
    shl    bx,2
    mov    dx,[si+bx]            {get x/y coords}
    mov    cx,[si+bx+2]

    mov    ax,l2                    {get second coords}
    shl    ax,2
    add    si,ax
    mov    ax,[si]                {get x/y coords}
    mov    bx,[si+2]

    cmp    bx,cx                    {make sure we go downwards...}
    jle    @noswap
    mov    si,[tex1x]            {swap texture x}
    xchg    [tex2x],si
    mov    [tex1x],si
    mov    si,[tex1y]            {swap texture y}
    xchg    [tex2y],si
    mov    [tex1y],si
    xchg    ax,dx                    {swap x}
    xchg    bx,cx                    {sway y}
@noswap:

    cmp    bx,[minx]            {record miny and maxy}
    jge    @minx
    mov    [minx],bx
@minx:
    cmp    cx,[maxx]
    jle    @maxx
    mov    [maxx],cx
@maxx:

    sub    cx,bx
    and    cx,cx
    jnz    @notzero
    jmp    @zero
@notzero:
    mov    [ysize],cx
    add    bx,bx
    add    bx,bx
    lea    si,slope
    add    si,bx

    push    ax
    sub    dx,ax
    inc    dx

    mov    ax,dx
    DB LONG; shl    ax,16
    {cdq} DB $66,$99
    DB LONG; idiv    cx
    DB LONG; mov    dx,ax
    DB LONG; shr    dx,16
    mov    [xlowadd],ax
    mov    [xhighadd],dx

    mov    ah,BYTE PTR [tex2x]
    sub    ah,BYTE PTR [tex1x]
    xor    al,al
    cwd
    idiv    cx
    mov    [tex1xadd],ax

    mov    ah,BYTE PTR [tex2y]
    sub    ah,BYTE PTR [tex1y]
    xor    al,al
    cwd
    idiv    cx
    mov    [tex1yadd],ax
@one:
    pop    cx

    xor    bx,bx
    mov    ah,BYTE PTR [tex1x]
    xor    al,al
    mov    dh,BYTE PTR [tex1y]
    xor    dl,dl
    mov    di,$8000
@loop:
    cmp    [si],di
    jne    @other
    mov    [si],cx
    mov    [si+TYPE(SlopeType)],ah
    mov    [si+TYPE(SlopeType)+1],dh
    add    si,4
    add    bx,[xlowadd]
    adc    cx,[xhighadd]
    add    ax,[tex1xadd]
    add    dx,[tex1yadd]
    dec    [ysize]
    jnz    @loop
    jmp    NEAR PTR @zero
@other:
    mov    [si+2],cx
    mov    [si+TYPE(SlopeType)+2],ah
    mov    [si+TYPE(SlopeType)+3],dh
    add    si,4
    add    bx,[xlowadd]
    adc    cx,[xhighadd]
    add    ax,[tex1xadd]
    add    dx,[tex1yadd]
    dec    [ysize]
    jnz    @loop
@zero:
end;


(*------------------------------------------------*)

procedure CalcAngle;
begin
    sin1:=sinustabel[v1]; cos1:=sinustabel[v1+128];
    sin2:=sinustabel[v2]; cos2:=sinustabel[v2+128];
    sin3:=sinustabel[v3]; cos3:=sinustabel[v3+128];
    v1:=(v1+2) AND 511; {change rotation angle}
    v2:=(v2-1) AND 511;
    v3:=(v3-1) AND 511;
end;

procedure RotateAllCoords; assembler;
{Rotate all coords in "coords" around all 3 axis and make
 perspective calcualtion. Store x,y,z results in "cbuffer"}
var
    xkoord,ykoord,zkoord, n : integer;
asm
    mov    ax,ds
    mov    es,ax
    lea    si,coords
    lea    di,cbuffer
    mov    [n],NUMBER_COORDS
    cld
@loop:
    lodsw
    mov    [xkoord],ax
    lodsw
    mov    [ykoord],ax
    lodsw
    mov    [zkoord],ax

    mov    ax,[xkoord]             {rotate around Z-axis}
    push    ax
    imul    [Cos1]
    add    ax,ax
    adc    dx,dx
    mov    bx,dx
    mov    ax,[ykoord]
    imul    [Sin1]
    add    ax,ax
    adc    dx,dx
    sub    bx,dx
    mov    [xkoord],bx
    pop    ax
    imul    [Sin1]
    add    ax,ax
    adc    dx,dx
    mov    bx,dx
    mov    ax,[ykoord]
    imul    [Cos1]
    add    ax,ax
    adc    dx,dx
    add    bx,dx
    mov    [ykoord],bx

    mov    ax,[ykoord]             {rotate around Y-axis}
    push    ax
    imul    [Cos2]
    add    ax,ax
    adc    dx,dx
    mov    bx,dx
    mov    ax,[zkoord]
    imul    [Sin2]
    add    ax,ax
    adc    dx,dx
    sub    bx,dx
    mov    [ykoord],bx
    pop    ax
    imul    [Sin2]
    add    ax,ax
    adc    dx,dx
    mov    bx,dx
    mov    ax,[zkoord]
    imul    [Cos2]
    add    ax,ax
    adc    dx,dx
    add    bx,dx
    mov    [zkoord],bx

    mov    ax,[xkoord]             {rotate around X-axis}
    push    ax
    imul    [Cos3]
    add    ax,ax
    adc    dx,dx
    mov    bx,dx
    mov    ax,[zkoord]
    imul    [Sin3]
    add    ax,ax
    adc    dx,dx
    sub   bx,dx
    mov    [xkoord],bx
    pop    ax
    imul    [Sin3]
    add    ax,ax
    adc    dx,dx
    mov    bx,dx
    mov    ax,[zkoord]
    imul    [Cos3]
    add    ax,ax
    adc    dx,dx
    add    bx,dx
    mov    [zkoord],bx

    add    bx,800
    and    bx,bx
    jnz    @zero
    mov    bl,1
@zero:

    mov    ax,[xkoord]
    cwd
    mov    dl,ah
    mov    ah,al
    xor    al,al
    idiv    bx
    add    ax,100
    stosw

    mov    ax,[ykoord]
    cwd
    mov    dl,ah
    mov    ah,al
    xor    al,al
    idiv    bx
    add    ax,160
    stosw

    dec    [n]
    jnz    @loop
end;



function FaceShown(i : integer; l1,l2,l3 : word) : boolean;
var
    a,b : longint;
begin
    a := LongMul(cbuffer[l1]-cbuffer[l2],cbuffer[l3+1]-cbuffer[l2+1]);
    b := LongMul(cbuffer[l1+1]-cbuffer[l2+1],cbuffer[l3]-cbuffer[l2]);
    FaceShown := (a-b) > 0;
    light[i]:=15-LongDiv(a-b,490);
end;


procedure FillShape(x,xsize : integer; light : word); assembler;
{Fill textured polygon by texturing vertical lines.
 Slow because of byte writes to VGA memory!}
var
    tex1,tex2 : word;
    xlowadd,xhighadd,ylowadd,yhighadd : word;
    loops : word;
    bitxpos : byte;
asm
    cmp    [xsize],320
    jb        @drawit
    jmp    @done
@drawit:
    mov    di,[display1]
    mov    ax,[x]
    shr    ax,2
    add    di,ax

    lea    si,slope
    mov    ax,[x]
    mov    cx,ax
    shl    ax,2
    add    si,ax

    and    cl,3
    mov    al,$11
    shl    al,cl
    mov    [bitxpos],al

    mov    es,[SEGA000]
    cld
@xloop:
    mov    dx,$3C4
    mov    ah,[bitxpos]
    mov    al,$02
    out    dx,ax

    mov    cx,[si+TYPE(slopetype)] {fetch texture x,y values}
    lodsw                                    {fetch first ypos}
    mov    dx,ax
    mov    bx,[si+TYPE(slopetype)] {fetch second texture x,y values}
    lodsw                                    {fetch second ypos}
    cmp    ax,dx                            {need to go downwards..}
    jle    @exchange
    xchg    ax,dx
    xchg    cx,bx
@exchange:
    mov    [tex1],cx
    mov    [tex2],bx

    push    si
    push    di

    DB LONG; xor cx,cx
    mov    cx,dx
    sub    cx,ax
    or        cx,cx
    jnz    @y_is_great
    jmp    @filledout
@y_is_great:
    add    ax,ax
    mov    bx,ax
    add    di,[OFFSET ytabel+bx]
    mov    [loops],cx

    push    ds
    push    bp

    mov    al,BYTE PTR [tex1]
    sub    al,BYTE PTR [tex2]
    cbw
    DB LONG; shl    ax,16
    {cdq} DB $66,$99
    DB LONG; idiv    cx
    DB LONG; mov    dx,ax
    DB LONG; shr    dx,16
    mov    [xlowadd],ax
    mov    [xhighadd],dx

    mov    al,BYTE PTR [tex1+1]
    sub    al,BYTE PTR [tex2+1]
    cbw
    DB LONG; shl    ax,16
    {cdq} DB $66,$99
    DB LONG; idiv    cx
    DB LONG; mov    dx,ax
    DB LONG; shr    dx,16
    mov    [ylowadd],ax
    mov    [yhighadd],dx

    DB LONG; xor dx,dx
    mov    dx,[yhighadd]

    mov    ax,[xlowadd]
    DB LONG; shl ax,16

    mov    bx,[ylowadd]
    DB LONG; shl bx,16
    mov    bx,[xhighadd]
    DB LONG; mov si,bx

    DB LONG; xor bx,bx
    mov    bl,BYTE PTR [tex2]
    mov    bh,BYTE PTR [tex2+1]
    DB LONG; xor cx,cx
    mov    cx,[loops]
    mov    ds,WORD PTR [texture+2]
    mov    bp,[light]
@loop:
    DB LONG; add cx,ax
    DB LONG; adc bx,si
    adc    bh,dl
    mov    dh,[bx]
    add    dx,bp                {add light factor}
    mov    [es:di],dh
    add    di,80
    dec    cx
    jnz    @loop

    pop    bp
    pop    ds

@filledout:
    pop    di
    pop    si
@filledout_fast:
    rol    [bitxpos],1
    adc    di,0
    dec    [xsize]
    jnz    @xloop
@done:
end;


procedure RunOnce;
var
    i : integer;
begin
    SwapDisplay;
    VBLANK;
{$IFDEF DEBUG}
    SetRGB(0,16,0,0);
{$ENDIF}

    ClearScreen;

    CalcAngle;
    RotateAllCoords;

    for i:=1 to NUMBER_FACES do begin
        with face[i] do if FaceShown(i, l1 SHL 1,l2 SHL 1,l3 SHL 1) then begin
            ClearSlope;
            minx := 320; maxx := 0;
            CalcSlope(l1,l2, 0,0,127,0);
            CalcSlope(l2,l3, 127,0,127,127);
            CalcSlope(l3,l4, 127,127,0,127);
            CalcSlope(l4,l1, 0,127,0,0);
            FillShape(minx, maxx-minx, light[i] SHL 12);
        end;
    end;

{$IFDEF DEBUG}
    SetRGB(0,0,0,0);
    while KeyHit[26] do ; {Hit 'P' to pause}
{$ENDIF}
end;


begin
    OpenScreen;
    InitDemo;
    SetAllInterrupts;
    repeat RunOnce until Key='e';
    RestoreAllInterrupts;
    UninitDemo;
    CloseScreen;
end.